home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / facilis.zip / INTERPRT.PAS < prev    next >
Pascal/Delphi Source File  |  1985-03-05  |  32KB  |  1,071 lines
  1. { Facilis 0.20                                    file: INTERPRT.PAS     }
  2. {$R-}
  3.  
  4. overlay procedure interpret;
  5.  
  6. var
  7.      b,b0: integer;   { base index }
  8.   h1,h2,h3,h4,h5,h6: integer;   { temporaries }
  9.      blkcnt, chrcnt: integer;   { counters }
  10.  jumpbase: integer;   { address of jump table }
  11.     sbuff: string[80];
  12.        ps: (run,fin,stkchk,caschk,divchk,inxchk,redchk,strchk,syschk);
  13.  
  14.   fld    : array [1..4] of integer;     { default field widths }
  15.   s      : array [0..stacksize] of      { blockmark:               }
  16.        record
  17.          case cn:types of               {    s[b+0] = fct result   }
  18.          ints:  (  i: integer);         {    s[b+1] = return adr   }
  19.          reals: (  r: real);            {    s[b+2] = static link  }
  20.          bools: (  b: boolean);         {    s[b+3] = dynamic link }
  21.          chars: (  c: char);            {    s[b+4] = table index  }
  22.          strngs:(s,p: integer);         {    s[b+5] = string ptr   }
  23.        end;
  24.  
  25.   procedure dump;
  26.  
  27.   var    p,h3 :integer;
  28.  
  29.   begin
  30.     h3:=tab[h2].lev;
  31.     writeln(psout);writeln(psout);
  32.     writeln(psout,'        calling ',tab[h2].name);
  33.     writeln(psout,'          level ',h3:4);
  34.     writeln(psout,' start of  code ',pc:4);
  35.     writeln(psout);writeln(psout);
  36.     writeln(psout,' contents of display '); writeln(psout);
  37.  
  38.     for p:=h3+1 downto 1 do writeln(psout,p:4,display[p]:6);
  39.  
  40.     writeln(psout);writeln(psout);
  41.     writeln(psout,' top of stack   ',t:4,' frame base ':14,b:4);
  42.     writeln(psout);writeln(psout);
  43.     writeln(psout,'stack contents':20); writeln(psout);
  44.  
  45.     for  p:=t  downto  1  do writeln(psout,p:14,s[p].i:8);
  46.  
  47.     writeln(psout,'< = = = >':22)
  48.   end; {  dump  }
  49.  
  50.   function get(var s:integer; t:integer): boolean;
  51.  
  52.   var v:integer;
  53.  
  54.   begin
  55.     v := ((t+3) div 16 +1)*16;
  56.     if (v < 1) or (v shr 4 > maxavail)
  57.     then begin ps := strchk; get := false; end
  58.     else begin
  59.       get := true;
  60.       getmem(spnt,v); s := seg(spnt^);
  61.       memw[s:0] := t;
  62.       memw[s:2] := v-4;
  63.     end
  64.   end;
  65.  
  66.   procedure free(p:integer);
  67.  
  68.   begin
  69.     tpnt := ptr(p,0);
  70.     freemem(tpnt,memw[p:2]+4)
  71.   end;
  72.  
  73.   procedure link(j:integer);
  74.  
  75.   var i: integer;
  76.  
  77.   begin
  78.     b0 := b;
  79.     i := tab[s[b0+4].i].lev;
  80.     while j<b0 do begin
  81.       b0 := display[i]; i := i-1; end;
  82.     s[j].p := s[b0+5].i;
  83.     s[b0+5].i := j;
  84.     s[j].cn := strngs
  85.   end;
  86.  
  87. function scopy(lf,rt:integer): boolean;
  88.  
  89. var h1,h2,h3,h4: integer;
  90.  
  91. begin
  92.   scopy := true;
  93.   h1 := s[lf].s;
  94.   h2 := memw[h1:2];
  95.   h3 := s[rt].s;
  96.   h4 := memw[h3:0];
  97.   if (h1 = 0) or (h2 < h4) or (h2 >= h4+16)
  98.   then begin
  99.     if h1=0 then link(lf)
  100.             else if h2<>0 then free(h1);
  101.     if not get(h1,h4) then scopy := false;
  102.     s[lf].s := h1;
  103.   end else memw[h1:0] := h4;
  104.   if ps = run then move(mem[h3:4],mem[h1:4],h4)
  105. end;
  106.  
  107. label start,loop,windup,
  108.      0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,
  109.      27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,
  110.      51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,
  111.      75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,
  112.      99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,
  113.      117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,
  114.      135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,
  115.      153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,
  116.      171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,
  117.      189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,
  118.      207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,
  119.      225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,
  120.      243,244,245,246,247,248,249,250,251,252,253,254,255;
  121.  
  122. begin { interpret }
  123.   inline(              { find base address of jump table }
  124.     $b8/*+12/          { MOV AX,*+12     }
  125.     $89/$86/jumpbase ); { MOV [BP]jumpbase,AX }
  126.   goto start;
  127.   goto windup;
  128. { each of these GOTOs compiles to a JMP to one of the interpreter routines }
  129.   goto   0;goto   1;goto   2;goto   3;goto   4;goto   5;goto   6;goto   7;
  130.   goto   8;goto   9;goto  10;goto  11;goto  12;goto  13;goto  14;goto  15;
  131.   goto  16;goto  17;goto  18;goto  19;goto  20;goto  21;goto  22;goto  23;
  132.   goto  24;goto  25;goto  26;goto  27;goto  28;goto  29;goto  30;goto  31;
  133.   goto  32;goto  33;goto  34;goto  35;goto  36;goto  37;goto  38;goto  39;
  134.   goto  40;goto  41;goto  42;goto  43;goto  44;goto  45;goto  46;goto  47;
  135.   goto  48;goto  49;goto  50;goto  51;goto  52;goto  53;goto  54;goto  55;
  136.   goto  56;goto  57;goto  58;goto  59;goto  60;goto  61;goto  62;goto  63;
  137.   goto  64;goto  65;goto  66;goto  67;goto  68;goto  69;goto  70;goto  71;
  138.   goto  72;goto  73;goto  74;goto  75;goto  76;goto  77;goto  78;goto  79;
  139.   goto  80;goto  81;goto  82;goto  83;goto  84;goto  85;goto  86;goto  87;
  140.   goto  88;goto  89;goto  90;goto  91;goto  92;goto  93;goto  94;goto  95;
  141.   goto  96;goto  97;goto  98;goto  99;goto 100;goto 101;goto 102;goto 103;
  142.   goto 104;goto 105;goto 106;goto 107;goto 108;goto 109;goto 110;goto 111;
  143.   goto 112;goto 113;goto 114;goto 115;goto 116;goto 117;goto 118;goto 119;
  144.   goto 120;goto 121;goto 122;goto 123;goto 124;goto 125;goto 126;goto 127;
  145.   goto 128;goto 129;goto 130;goto 131;goto 132;goto 133;goto 134;goto 135;
  146.   goto 136;goto 137;goto 138;goto 139;goto 140;goto 141;goto 142;goto 143;
  147.   goto 144;goto 145;goto 146;goto 147;goto 148;goto 149;goto 150;goto 151;
  148.   goto 152;goto 153;goto 154;goto 155;goto 156;goto 157;goto 158;goto 159;
  149.   goto 160;goto 161;goto 162;goto 163;goto 164;goto 165;goto 166;goto 167;
  150.   goto 168;goto 169;goto 170;goto 171;goto 172;goto 173;goto 174;goto 175;
  151.   goto 176;goto 177;goto 178;goto 179;goto 180;goto 181;goto 182;goto 183;
  152.   goto 184;goto 185;goto 186;goto 187;goto 188;goto 189;goto 190;goto 191;
  153.   goto 192;goto 193;goto 194;goto 195;goto 196;goto 197;goto 198;goto 199;
  154.   goto 200;goto 201;goto 202;goto 203;goto 204;goto 205;goto 206;goto 207;
  155.   goto 208;goto 209;goto 210;goto 211;goto 212;goto 213;goto 214;goto 215;
  156.   goto 216;goto 217;goto 218;goto 219;goto 220;goto 221;goto 222;goto 223;
  157.   goto 224;goto 225;goto 226;goto 227;goto 228;goto 229;goto 230;goto 231;
  158.   goto 232;goto 233;goto 234;goto 235;goto 236;goto 237;goto 238;goto 239;
  159.   goto 240;goto 241;goto 242;goto 243;goto 244;goto 245;goto 246;goto 247;
  160.   goto 248;goto 249;goto 250;goto 251;goto 252;goto 253;goto 254;goto 255;
  161.  
  162. start:
  163.       s[1].i := 0;    s[2].i := 0;
  164.       s[3].i := -1;   s[4].i := btab[1].last;
  165.   display[1] := 0;         t := btab[2].vsize - 1;
  166.            b := 0;        pc := tab[s[4].i].adr;
  167.       chrcnt := 0;        ps := run;
  168.  
  169.       fld[1] := 8;    fld[2] := 20;
  170.       fld[3] := 8;    fld[4] := 1;
  171.  
  172.   if t > stacksize
  173.   then begin
  174.     ps := stkchk; goto windup; end;
  175.   fillchar(s[5],(t-4)*sizeof(s[1]),0);
  176.  
  177. loop:            { here starts the main loop of the interpreter }
  178. Inline(
  179.    $8B/$3E/pc              { MOV DI,pc       ;get program counter }
  180.   /$FF/$06/pc              { INC (W)pc }
  181.   /$D1/$E7                 { SHL DI,=1       ;*4 (bytes per p-code) }
  182.   /$D1/$E7                 { SHL DI,=1       ;index into code array }
  183.   /$81/$C7/code            { ADD DI,=code    ;leave ptr to p-code in DI }
  184.   /$8B/$45/2               { MOV AX,[DI]2    ;get y operand }
  185.   /$A3/y                   { MOV y,AX }
  186.   /$8A/$1D                 { MOV BL,[DI]     ;get opcode }
  187.   /$88/$1E/opcode          { MOV opcode,BL }
  188.   /$32/$FF                 { XOR BH,BH       ;leave opcode in BX }
  189.   /$8B/$F3                 { MOV SI,BX       ;*3 (bytes per JMP) }
  190.   /$03/$F3                 { ADD SI,BX }
  191.   /$03/$F3                 { ADD SI,BX }
  192.   /$03/$B6/jumpbase        { ADD SI,[BP]jumpbase ;index into jump table }
  193.   /$FF/$E6                 { JMP SI          ;jump through table }
  194.   );
  195.  
  196.  
  197.     0: { load address }
  198.       inline(
  199.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  200.        /$A2/x );                   { MOV x,AL }
  201.       t := t+1;
  202.       if t > stacksize
  203.       then begin
  204.         ps := stkchk; goto windup; end
  205.       else s[t].i := display[x] + y;
  206.       goto loop;
  207.  
  208.     1: { load value }
  209.       inline(
  210.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  211.        /$A2/x );                   { MOV x,AL }
  212.       t := t+1;
  213.       if t > stacksize
  214.       then begin
  215.         ps := stkchk; goto windup; end
  216.       else s[t] := s[display[x] + y];
  217.       goto loop;
  218.  
  219.     2: { load indirect }
  220.       inline(
  221.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  222.        /$A2/x );                   { MOV x,AL }
  223.       t := t+1;
  224.       if t > stacksize
  225.       then begin
  226.         ps := stkchk; goto windup; end
  227.         else s[t] := s[s[display[x] + y].i];
  228.       goto loop;
  229.  
  230.     3: { update display }
  231.       inline(
  232.         $8A/$45/1                  { MOV AL,[DI]1    ;get x operand }
  233.        /$A2/x );                   { MOV x,AL }
  234.       h1 := y; h2 := x; h3 := b;
  235.       repeat
  236.         display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
  237.       until h1 = h2;
  238.       goto loop;
  239.  
  240.     4:5:6: ps := syschk; goto windup;
  241.  
  242.     7: case y and 3 of    { concatenation }
  243.       0: begin   {char+char}
  244.            if not get(h1,2) then goto windup;
  245.            mem[h1:4] := s[t-1].i;
  246.            mem[h1:5] := s[t].i;
  247.            t := t-1;
  248.            s[t].i := h1;
  249.          end;
  250.       1: begin   {string+char}
  251.            h1 := s[t-1].i;
  252.            h2 := memw[h1:0];
  253.            if not get(h3,h2+1) then goto windup;
  254.            move(mem[h1:4],mem[h3:4],h2);
  255.            if (y and 4) = 4 then free(h1);
  256.            mem[h3:h2+4] := s[t].i;
  257.            t := t-1;
  258.            s[t].i := h3;
  259.          end;
  260.       2: begin   {char+string}
  261.            h1 := s[t].i;
  262.            h2 := memw[h1:0];
  263.            if not get(h4,h2+1) then goto windup;
  264.            move(mem[h1:4],mem[h4:5],h2);
  265.            mem[h4:4] := s[t-1].i;
  266.            if (y and 8) = 8 then free(h1);
  267.            t := t-1;
  268.            s[t].i := h4;
  269.          end;
  270.       3: begin   {string+string}
  271.            h5 := s[t-1].i;
  272.            h6 := s[t].i;
  273.            h3 := memw[h5:0];
  274.            h4 := memw[h6:0];
  275.            if not get(h2,h3+h4) then goto windup;
  276.            move(mem[h5:4],mem[h2:4],h3);
  277.            move(mem[h6:4],mem[h2:h3+4],h4);
  278.            if (y and 4) = 4 then free(h5);
  279.            if (y and 8) = 8 then free(h6);
  280.            t := t-1;
  281.            s[t].i := h2;
  282.          end;
  283.        end;
  284.        goto loop;
  285.  
  286.     8: if y < 10 then
  287.        case y of
  288.       0: s[t].i := abs(s[t].i);
  289.       1: s[t].r := abs(s[t].r);
  290.       2: s[t].i := sqr(s[t].i);
  291.       3: s[t].r := sqr(s[t].r);
  292.       4: s[t].b := odd(s[t].i);
  293.       5: s[t].c := chr(s[t].i);
  294.       6: s[t].i := ord(s[t].c);
  295.       7: s[t].c := succ(s[t].c);
  296.       8: s[t].c := pred(s[t].c);
  297.       9: s[t].i := round(s[t].r);
  298.        end
  299.  
  300.        else if y < 20 then
  301.        case y of
  302.      10: s[t].i := trunc(s[t].r);
  303.      11: s[t].r := sin(s[t].r);
  304.      12: s[t].r := cos(s[t].r);
  305.      13: s[t].r := exp(s[t].r);
  306.      14: s[t].r := ln(s[t].r);
  307.      15: s[t].r := sqrt(s[t].r);
  308.      16: s[t].r := arctan(s[t].r);
  309.      17: begin
  310.            t := t+1;
  311.            if t > stacksize
  312.            then begin
  313.              ps := stkchk; goto windup; end
  314.            else s[t].b := eof(prd)
  315.          end;
  316.      18: begin
  317.            t := t+1;
  318.            if t > stacksize
  319.            then begin
  320.              ps := stkchk; goto windup; end
  321.            else s[t].b := eoln(prd)
  322.          end;
  323.      19: begin
  324.            t := t+1;
  325.            if t > stacksize
  326.            then begin
  327.              ps := stkchk; goto windup; end
  328.            else s[t].i := maxavail
  329.          end;
  330.  
  331.        end
  332.        else if y < 33 then
  333.        case y of
  334.  
  335.      20: s[t].i := memw[s[t].i:0];
  336.      21: begin
  337.            h1 := s[t].i;
  338.            s[t].i := memw[h1:0];
  339.            spnt := ptr(h1,0); freemem(spnt,memw[h1:2]+4)
  340.          end;
  341.      22: s[t].i := 1;
  342.      23: begin
  343.            h1 := s[t-2].i;
  344.            h4 := memw[h1:0];
  345.            h2 := s[t-1].i;
  346.            if (h2 < 1) or (h2 > h4)
  347.            then begin h4 := 0; h2 := 2; end;
  348.            h3 := s[t].i;
  349.            if h3 > h4-h2+1 then h3 := h4-h2+1;
  350.            if h3 < 0 then h3 := 0;
  351.            if not get(h5,h3) then goto windup;
  352.            move(mem[h1:h2+3],mem[h5:4],h3);
  353.            s[t-2].i := h5;
  354.            t := t-2;
  355.          end;
  356.      24: begin
  357.            h1 := s[t-2].i;
  358.            h4 := memw[h1:0];
  359.            h2 := s[t-1].i;
  360.            if (h2 < 1) or (h2 > h4)
  361.            then memw[h1:0] := 0
  362.            else begin
  363.              h3 := s[t].i;
  364.              if h3 > h4-h2+1 then h3 := h4-h2+1;
  365.              if h3 < 0 then h3 := 0;
  366.              move(mem[h1:h2+3],mem[h1:4],h3);
  367.              memw[h1:0] := h3;
  368.            end;
  369.            t := t-2;
  370.          end;
  371.  
  372.      25: begin
  373.            if not get(h1,1) then goto windup;
  374.            if (s[t-1].i = 1) and (s[t].i > 0)
  375.            then mem[h1:4] := s[t-2].i
  376.            else memw[h1:0] := 0;
  377.            s[t-2].i := h1;
  378.            t := t-2;
  379.          end;
  380.  
  381.  26,27,30,31:
  382.          begin
  383.            h1 := s[t-1].i;
  384.            h2 := s[t].i;   t := t-1;
  385.            h6 := memw[h1:0]+4;
  386.            h3 := memw[h2:0]+5-h6;
  387.            if (h3<=0) or (h6=4)
  388.            then s[t].i := 0
  389.            else begin
  390.              h4 := 0;
  391.              while h4<h3 do begin
  392.                h5 := 4;
  393.                while (h5<h6) and (mem[h1:h5]=mem[h2:h4+h5]) do h5 := h5+1;
  394.                if h5=h6 then h3:=h4-1 else h4 := h4+1;
  395.              end;
  396.              if h3=h4 then s[t].i := 0 else s[t].i := h4+1;
  397.            end;
  398.            if odd(y) then free(h1);
  399.            if y > 29 then free(h2);
  400.          end;
  401.  
  402.   28,32: begin
  403.            h1 := s[t-1].i;
  404.            h2 := s[t].i;
  405.            h3 := memw[h2:0]+4;
  406.            h4 := 4;
  407.            while (h4<h3) and (mem[h2:h4]<>h1) do h4 := h4+1;
  408.            if y=32 then free(h3);
  409.            t := t-1;
  410.            if h4<h3 then s[t].i := h4-3 else s[t].i := 0;
  411.          end;
  412.  
  413.        end
  414.        else if y < 40 then
  415.        case y of
  416.  
  417.   33,34: begin
  418.            if y=34 then str(s[t].r:18,sbuff)
  419.                       else str(s[t].i:1,sbuff);
  420.            h2 := length(sbuff);
  421.            if not get(h1,h2) then goto windup;
  422.            move(sbuff[1],mem[h1:4],h2);
  423.            s[t].i := h1
  424.          end;
  425.  
  426. 35,36,37,38:
  427.          begin
  428.            h1 := s[t].i;
  429.            h2 := memw[h1:0]; sbuff := '';
  430.            move(mem[h1:4],sbuff[1],h2);
  431.            sbuff[0] := chr(h2);
  432.            if y < 37 then val(sbuff,s[t].i,h5)
  433.                         else val(sbuff,s[t].r,h5);
  434.            if not odd(y) then free(h1)
  435.          end;
  436.  
  437.          else begin
  438.                 ps := syschk; goto windup;
  439.               end;
  440.  
  441.        end ; { functions }
  442.        goto loop;
  443.  
  444.     9: s[t].i := s[t].i + y;   { offset }
  445.        goto loop;
  446.  
  447.    10: pc := y;  { jump }
  448.        goto loop;
  449.  
  450.    11: { conditional jump }
  451.          if not s[t].b then pc := y;
  452.          t := t-1;
  453.        goto loop;
  454.  
  455.    12: { switch }
  456.          h1 := s[t].i;      t := t-1;
  457.          h2 := y;       h3 := 0;
  458.          repeat
  459.            if code[h2].f <> 13
  460.            then begin
  461.              ps := caschk; goto windup; end
  462.            else if code[h2].y = h1
  463.                     then begin
  464.                       h3 := 1;
  465.                       pc := code[h2+1].y
  466.                     end else h2 := h2 + 2
  467.          until h3 <> 0;
  468.        goto loop;
  469.  
  470.    13: ps := syschk; goto windup;  {case marker}
  471.  
  472.    14: { for1up }
  473.          h1 := s[t-1].i;
  474.          if h1 <= s[t].i
  475.          then s[s[t-2].i].i := h1
  476.          else begin
  477.            t := t-3;
  478.            pc := y
  479.          end;
  480.        goto loop;
  481.  
  482.    15: { for2up }
  483.          h2 := s[t-2].i;
  484.          h1 := s[h2].i +1;
  485.          if h1 <= s[t].i
  486.          then begin
  487.            s[h2].i := h1; pc := y
  488.          end else t := t-3;
  489.        goto loop;
  490.  
  491.    16: { for1down }
  492.          h1 := s[t-1].i;
  493.          if h1 >= s[t].i
  494.          then s[s[t-2].i].i := h1
  495.          else begin
  496.            pc := y; t := t-3
  497.          end;
  498.        goto loop;
  499.  
  500.    17: { for2down }
  501.          h2 := s[t-2].i;
  502.          h1 := s[h2].i - 1;
  503.          if h1 >= s[t].i
  504.          then begin
  505.            s[h2].i := h1; pc := y
  506.          end else t := t-3;
  507.        goto loop;
  508.  
  509.    18: { mark stack }
  510.          h1 := btab[tab[y].ref].vsize;
  511.          if t+h1 > stacksize
  512.          then begin
  513.            ps := stkchk; goto windup; end
  514.          else begin
  515.            t := t+6;  b0 := t;  s[b0].i := 0;
  516.            s[t-2].i := h1-1;    s[t-1].i := y
  517.          end;
  518.        goto loop;
  519.  
  520.    19: { call }
  521.          h1 := t - y;             { h1 points to base }
  522.          h2 := s[h1+4].i;            { h2 points to tab }
  523.          h3 := tab[h2].lev;    display[h3+1] := h1;
  524.          h4 := s[h1+3].i + h1;
  525.          s[h1+1].i := pc;      s[h1+2].i := display[h3];
  526.          s[h1+3].i := b;
  527.          fillchar(s[t+1],(h4-t)*sizeof(s[1]),0);
  528.          b := h1;    t := h4;
  529.          pc := tab[h2].adr;
  530.          if stackdump then dump;
  531.        goto loop;
  532.  
  533.    20: { index1 }
  534.          h1 := y;      { h1 points to atab }
  535.          h2 := atab[h1].low;
  536.          h3 := s[t].i;
  537.          if h3 < h2
  538.          then begin
  539.            ps := inxchk; goto windup; end
  540.          else if h3 > atab[h1].high
  541.               then begin
  542.                 ps := inxchk; goto windup; end
  543.               else begin
  544.                 t := t-1;
  545.                 s[t].i := s[t].i + (h3-h2)
  546.               end;
  547.        goto loop;
  548.  
  549.    21: { index }
  550.          h1 := y;      { h1 points to atab }
  551.          h2 := atab[h1].low;
  552.          h3 := s[t].i;
  553.          if h3 < h2
  554.          then begin
  555.            ps := inxchk; goto windup; end
  556.          else if h3 > atab[h1].high
  557.               then begin
  558.                 ps := inxchk; goto windup; end
  559.               else begin
  560.                 t := t-1;
  561.                 s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
  562.               end;
  563.        goto loop;
  564.  
  565.    22: { load block }
  566.          h1 := s[t].i;     t := t-1;
  567.          h2 := y + t;
  568.          if h2 > stacksize
  569.          then begin
  570.            ps := stkchk; goto windup; end
  571.          else while t < h2 do
  572.            begin
  573.              t := t+1;
  574.              if s[h1].cn = strngs
  575.              then begin
  576.                s[t].s := 0;
  577.                if not scopy(t,h1) then goto windup; end
  578.              else s[t] := s[h1];
  579.              h1 := h1+1
  580.            end;
  581.        goto loop;
  582.  
  583.    23: { copy block }
  584.          h1 := s[t-1].i;
  585.          h2 := s[t].i;
  586.          h3 := h1 + y;
  587.          while h1 < h3 do
  588.          begin
  589.            if s[h2].cn = strngs
  590.            then begin
  591.              s[h1].s := 0;
  592.              if not scopy(h1,h2) then goto windup; end
  593.            else s[h1] := s[h2];
  594.            h1 := h1+1;    h2 := h2+1
  595.          end;
  596.          t := t-2;
  597.        goto loop;
  598.  
  599.    24: { literal }
  600.          t := t+1;
  601.          if t > stacksize
  602.          then begin
  603.            ps := stkchk; goto windup; end
  604.          else s[t].i := y;
  605.        goto loop;
  606.  
  607.    25: { load real }
  608.          t := t+1;
  609.          if t > stacksize
  610.          then begin
  611.            ps := stkchk; goto windup; end
  612.          else s[t].r := rconst[y];
  613.        goto loop;
  614.  
  615.    26: { float }
  616.          h1 := t - y;
  617.          s[h1].r := s[h1].i;
  618.        goto loop;
  619.  
  620.    27: { read }
  621.          case y of
  622.         1: read(prd,s[s[t].i].i);
  623.         2: read(prd,s[s[t].i].r);
  624.         4: read(prd,s[s[t].i].c);
  625.         5: begin
  626.              read(prd,sbuff);
  627.              h1 := length(sbuff);
  628.              if h1=0
  629.              then h3 := nul
  630.              else begin
  631.                if not get(h3,h1) then goto windup;
  632.                move(sbuff[1],mem[h3:4],h1);
  633.              end;
  634.              h4 := s[t].i; h5 := s[h4].i;
  635.              if h5 = 0 then link(h4)
  636.                        else if memw[h5:2] <> 0 then free(h5);
  637.              s[h4].i := h3;
  638.            end
  639.          end ;
  640.  
  641.          t := t-1;
  642.        goto loop;
  643.  
  644.    28: ps := syschk; goto windup;
  645.  
  646.    29: { write1 }
  647.          chrcnt := chrcnt + fld[y];
  648.          if chrcnt > lineleng
  649.          then begin
  650.            writeln(prr); chrcnt := 0; end;
  651.          case y of
  652.              1: write(prr,s[t].i: fld[1]);
  653.              2: write(prr,s[t].r: fld[2]);
  654.              3: if s[t].b then write ('true':fld[3])
  655.                           else write ('false':fld[3]);
  656.              4: write(prr,chr(s[t].i));
  657.          end ;
  658.          t := t-1;
  659.        goto loop;
  660.  
  661.    30: { write2 }
  662.          chrcnt := chrcnt + s[t].i;
  663.          if chrcnt > lineleng
  664.          then begin
  665.            writeln(prr); chrcnt := 0; end;
  666.          case y of
  667.              1: write(prr,s[t-1].i: s[t].i);
  668.              2: write(prr,s[t-1].r: s[t].i);
  669.              3: if s[t-1].b then write ('true') else write ('false');
  670.              4: write(prr,chr(s[t-1].i): s[t].i);
  671.          end ;
  672.          t := t-2;
  673.        goto loop;
  674.  
  675.    31: { chars := strngs }
  676.          h1 := s[t].i;
  677.          if memw[h1:0] <> 1
  678.          then begin
  679.            ps := strchk; goto windup; end
  680.          else begin
  681.            s[s[t-1].i].i := mem[h1:4];
  682.            if (y and 8) = 8 then free(h1)
  683.          end;
  684.          t := t-2;
  685.        goto loop;
  686.  
  687.    32: { string relations }
  688.          h2 := s[t-1].i;
  689.          h3 := s[t].i;
  690.          case y and 3 of
  691.         1: begin  {strngs~chars}
  692.              h4 := memw[h2:0];
  693.              if h4=0 then h5 := 64
  694.              else if h3>mem[h2:4] then h5 := 64
  695.              else if h3<mem[h2:4] then h5 := 32
  696.              else if h4=1 then h5 := 16
  697.              else h5 := 32;
  698.            end;
  699.         2: begin  {chars~strngs}
  700.              h4 := memw[h3:0];
  701.              if h4=0 then h5 := 32
  702.              else if h2>mem[h3:4] then h5 := 32
  703.              else if h2<mem[h3:4] then h5 := 64
  704.              else if h4=1 then h5 := 16
  705.              else h5 := 64;
  706.            end;
  707.         3: begin  {strngs~strngs}
  708.              h4 := memw[h2:0]; h1 :=0;
  709.              h5 := memw[h3:0];
  710.              if h5<h4 then h4 := h5 else h5 := h4;
  711.              while h1<h4 do begin
  712.                if mem[h2:4+h1] <> mem[h3:4+h1]
  713.                then h4 := h1
  714.                else h1 := h1+1;
  715.              end;
  716.              if h4=h5
  717.              then if memw[h2:0]=memw[h3:0]
  718.                   then h5 := 16
  719.                   else if memw[h2:0]<memw[h3:0]
  720.                        then h5 := 64 else h5 := 32
  721.              else if mem[h2:4+h1]<mem[h3:4+h1]
  722.                   then h5 := 64 else h5 := 32;
  723.            end;
  724.          end;
  725.          if (y and 5) = 5 then free(h2);
  726.          if (y and 10) = 10 then free(h3);
  727.          t := t-1;
  728.          s[t].b := (y and h5) > 0;
  729.        goto loop;
  730.  
  731.   33:34:35:36:37:38:39:40:41:42:43:44:45:46:47:48:49:50:51:52:53:54:55:56:57:
  732.   58:59:60:61:62:63:64:65:66:67:68:69:70:71:72:73:74:75:76:77:78:79:80:81:82:
  733.   83:84:85:86:87:88:89:90:91:92:93:94:95:96:97:98:99:100:101:102:103:104:105:
  734.   106:107:108:109:110:111:112:113:114:115:116:117:118:119:120:121:122:123:124:
  735.   125:126:127:128:129:130: ps := syschk; goto windup;
  736.  
  737.   131: ps := fin;
  738.        goto windup;
  739.  
  740.   132: { exit procedure }
  741.          h1 := s[b+5].i;
  742.          while h1 <> 0 do begin
  743.            free(s[h1].i);
  744.            h1 := s[h1].p; end;
  745.          t := b-1;
  746.          pc := s[b+1].i;  b := s[b+3].i;
  747.        goto loop;
  748.  
  749.   133: { exit function }
  750.          h1 := s[b+5].i;
  751.          while h1 <> 0 do begin
  752.            free(s[h1].i);
  753.            h1 := s[h1].p; end;
  754.          t := b;
  755.          pc := s[b+1].i;  b := s[b+3].i;
  756.        goto loop;
  757.  
  758.   134: s[t] := s[s[t].i]; goto loop;
  759.  
  760.   135: s[t].b := not s[t].b; goto loop;
  761.  
  762.   136: s[t].i := - s[t].i; goto loop;
  763.  
  764.   137:
  765.          chrcnt := chrcnt + s[t-1].i;
  766.          if chrcnt > lineleng
  767.          then begin
  768.            writeln(prr); chrcnt := 0; end
  769.          else write(prr,s[t-2].r: s[t-1].i: s[t].i);
  770.          t := t-3;
  771.        goto loop;
  772.  
  773.   138: { store }
  774.          s[s[t-1].i] := s[t];
  775.          t := t-2;
  776.        goto loop;
  777.  
  778.   139:
  779.          t := t-1;
  780.          s[t].b := s[t].r = s[t+1].r;
  781.        goto loop;
  782.  
  783.   140:
  784.          t := t-1;
  785.          s[t].b := s[t].r <> s[t+1].r;
  786.        goto loop;
  787.  
  788.   141:
  789.          t := t-1;
  790.          s[t].b := s[t].r < s[t+1].r;
  791.        goto loop;
  792.  
  793.   142:
  794.          t := t-1;
  795.          s[t].b := s[t].r <= s[t+1].r;
  796.        goto loop;
  797.  
  798.   143:
  799.          t := t-1;
  800.          s[t].b := s[t].r > s[t+1].r;
  801.        goto loop;
  802.  
  803.   144:
  804.          t := t-1;
  805.          s[t].b := s[t].r >= s[t+1].r;
  806.        goto loop;
  807.  
  808.   145:
  809.          t := t-1;
  810.          s[t].b := s[t].i = s[t+1].i;
  811.        goto loop;
  812.  
  813.   146:
  814.          t := t-1;
  815.          s[t].b := s[t].i <> s[t+1].i;
  816.        goto loop;
  817.  
  818.   147:
  819.          t := t-1;
  820.          s[t].b := s[t].i < s[t+1].i;
  821.        goto loop;
  822.  
  823.   148:
  824.          t := t-1;
  825.          s[t].b := s[t].i <= s[t+1].i;
  826.        goto loop;
  827.  
  828.   149:
  829.          t := t-1;
  830.          s[t].b := s[t].i > s[t+1].i;
  831.        goto loop;
  832.  
  833.   150:
  834.          t := t-1;
  835.          s[t].b := s[t].i >= s[t+1].i;
  836.        goto loop;
  837.  
  838.   151:
  839.          t := t-1;
  840.          s[t].b := s[t].b or s[t+1].b;
  841.        goto loop;
  842.  
  843.   152:
  844.          t := t-1;
  845.          s[t].i := s[t].i + s[t+1].i;
  846.        goto loop;
  847.  
  848.   153:
  849.          t := t-1;
  850.          s[t].i := s[t].i - s[t+1].i;
  851.        goto loop;
  852.  
  853.   154:
  854.          t := t-1;
  855.          s[t].r := s[t].r + s[t+1].r;
  856.        goto loop;
  857.  
  858.   155:
  859.          t := t-1;
  860.          s[t].r := s[t].r - s[t+1].r;
  861.        goto loop;
  862.  
  863.   156:
  864.          t := t-1;
  865.          s[t].b := s[t].b and s[t+1].b;
  866.        goto loop;
  867.  
  868.   157:
  869.          t := t-1;
  870.          s[t].i := s[t].i * s[t+1].i;
  871.        goto loop;
  872.  
  873.   158:
  874.          t := t-1;
  875.          if s[t+1].i = 0
  876.          then begin
  877.            ps := divchk; goto windup; end
  878.          else s[t].i := s[t].i div s[t+1].i;
  879.        goto loop;
  880.  
  881.   159:
  882.          t := t-1;
  883.          if s[t+1].i = 0
  884.          then begin
  885.            ps := divchk; goto windup; end
  886.          else s[t].i := s[t].i mod s[t+1].i;
  887.        goto loop;
  888.  
  889.   160:
  890.          t := t-1;
  891.          s[t].r := s[t].r * s[t+1].r;
  892.        goto loop;
  893.  
  894.   161:
  895.          t := t-1;
  896.          s[t].r := s[t].r / s[t+1].r;
  897.        goto loop;
  898.  
  899.   162: if eof(prd)
  900.        then begin
  901.               ps := redchk; goto windup; end
  902.        else readln;
  903.        goto loop;
  904.  
  905.   163:
  906.          writeln(prr);
  907.          chrcnt := 0;
  908.        goto loop;
  909.  
  910.   164: s[t].r := - s[t].r; goto loop;
  911.  
  912.   165: { index strngs }
  913.          h1 := s[t-1].i;
  914.          h2 := s[t].i;
  915.          if (h2 <= 0) or (h2 > memw[h1:0])
  916.          then begin
  917.            ps := inxchk; goto windup; end
  918.          else begin
  919.            t := t-1;
  920.            s[t].i := mem[h1:h2+3]
  921.          end;
  922.        goto loop;
  923.  
  924.   166: { strngs := temp }
  925.          h2 := s[t-1].i;
  926.          h1 := s[h2].i;
  927.          if h1=0 then link(h2)
  928.                  else if memw[h1:2] <> 0 then free(h1);
  929.          s[h2].i := s[t].i;
  930.          t := t-2;
  931.        goto loop;
  932.  
  933.   167: { convert array to string }
  934.          h1 := s[t].i;
  935.          if not get(h3,y) then goto windup;
  936.          for h4 := 0 to y-1 do mem[h3:4+h4] := ord(s[h1+h4].c);
  937.          s[t].i := h3;
  938.        goto loop;
  939.  
  940.   168: { strngs := chars }
  941.          h2 := s[s[t-1].i].i;
  942.          if (h2=0) or (memw[h2:2] > 12) then begin
  943.            if not get(h3,1) then goto windup;
  944.            if h2=0 then link(s[t-1].i) else free(h2);
  945.            h2 := h3;
  946.            s[s[t-1].i].i := h2; end;
  947.          mem[h2:4] := s[t].i;
  948.          memw[h2:0] := 1;
  949.          t := t-2;
  950.        goto loop;
  951.  
  952.   169: { strngs := strngs }
  953.          if not scopy(s[t-1].i, t) then goto windup;
  954.          t := t-2;
  955.        goto loop;
  956.  
  957.   170: 171: { write string }
  958.          h3 := s[t].i; t := t-1;
  959.          h2 := memw[h3:0] + 4;
  960.          h1 := 4;
  961.          while h1 < h2 do begin
  962.            write(prr,chr(mem[h3:h1]));
  963.            h1 := h1+1;
  964.          end;
  965.          if opcode = 171 then free(h3);
  966.          chrcnt := (chrcnt + h2 -4) mod lineleng;
  967.        goto loop;
  968.  
  969.   172: { string val param }
  970.          h1 := s[t].i;
  971.          h4 := memw[h1:0];
  972.          if not get(h2,h4) then goto windup;
  973.          move(mem[h1:4],mem[h2:4],h4);
  974.          s[t].i := h2;
  975.          s[t].p := s[b0].i;
  976.          s[b0].i := t;
  977.        goto loop;
  978.  
  979.   173: { temp val param }
  980.          s[t].p := s[b0].i;
  981.          s[b0].i := t;
  982.        goto loop;
  983.  
  984.   174: 175: { chararray := string }
  985.          h1 := s[t].i;
  986.          h2 := memw[h1:0];
  987.          h4 := s[t-1].i;
  988.          if h2>=y
  989.          then for h3 := 0 to y-1 do s[h4+h3].c := chr(mem[h1:4+h3])
  990.          else begin
  991.            for h3 := 0 to h2-1 do s[h4+h3].c := chr(mem[h1:4+h3]);
  992.            for h3 := h4+h2 to h4+y-1 do s[h3].c := ' '
  993.          end;
  994.          if opcode=175 then free(h1);
  995.          t := t-2;
  996.        goto loop;
  997.  
  998.   176: 177:  { write string - defined field }
  999.          h4 := s[t].i;
  1000.          h3 := s[t-1].i;
  1001.          h2 := memw[h3:0];
  1002.          if h2>=h4 then h2 := h4
  1003.                    else repeat
  1004.                      write(prr,' ');
  1005.                      h4 := h4-1;
  1006.                    until h4=h2;
  1007.          h1 := 4; h2 := h2+4;
  1008.          while h1 < h2 do begin
  1009.            write(prr,chr(mem[h3:h1]));
  1010.            h1 := h1+1
  1011.          end;
  1012.          if opcode=177 then free(h3);
  1013.          if chrcnt = 0 then chrcnt := s[t].i mod lineleng;
  1014.        goto loop;
  1015.  
  1016.   178:179:180:181:182:183:184:185:186:187:188:189:190:191:192:193:194:195:196:
  1017.   197:198:199:200:201:202:203:204:205:206:207:208:209:210:211:212:213:214:215:
  1018.   216:217:218:219:220:221:222:223:224:225:226:227:228:229:230:231:232:233:234:
  1019.   235:236:237:238:239:240:241:242:243:244:245:246:247:248:249:250:251:252:253:
  1020.   254:255: ps := syschk; goto windup;
  1021.  
  1022.  
  1023. windup:
  1024.   if ps <> fin
  1025.   then begin
  1026.     writeln(prr);
  1027.     write(prr,' halt at', pc-1:5, ' because of ');
  1028.     case ps of
  1029.       caschk: writeln(prr,'undefined case');
  1030.       divchk: writeln(prr,'division by 0');
  1031.       inxchk: writeln(prr,'invalid index');
  1032.       stkchk: writeln(prr,'storage overflow');
  1033.       redchk: writeln(prr,'reading past end of file');
  1034.       strchk: writeln(prr,'string length error');
  1035.       syschk: writeln(prr,'bug in compiler');
  1036.     end ;
  1037.   h1 := b; blkcnt := 10;   { post mortem dump }
  1038.   repeat
  1039.     writeln(prr); blkcnt := blkcnt - 1;
  1040.     if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i;
  1041.     if h1<>0
  1042.     then writeln(prr,' ', tab[h2].name, ' called at', s[h1+1].i: 5);
  1043.     h2 := btab[tab[h2].ref].last;
  1044.     while h2 <> 0 do
  1045.       with tab[h2] do
  1046.       begin
  1047.         if obj = vvariable
  1048.         then if typ in stantyps
  1049.              then begin
  1050.                write(prr,'    ', name, ' = ');
  1051.                if normal then h3 := h1+adr else h3 := s[h1+adr].i;
  1052.                case typ of
  1053.                  ints : writeln(prr,s[h3].i);
  1054.                  reals: writeln(prr,s[h3].r);
  1055.                  bools: if s[h3].b
  1056.                         then writeln(prr,'true')
  1057.                         else writeln(prr,'false');
  1058.                  chars: writeln(prr,chr(s[h3].i mod 64))
  1059.                end
  1060.              end ;
  1061.         h2 := link
  1062.       end ;
  1063.     h1 := s[h1+3].i
  1064.   until h1 < 0;
  1065.   end ;
  1066.  
  1067.   writeln(prr);
  1068.  
  1069. end ; { interpret }
  1070.  
  1071. {$R+}